Attribute VB_Name = "modObjectSafety"
'***************************************************************
' (c) Copyright 2000 Matthew J. Curland
'
' This file is from the CD-ROM accompanying the book:
' Advanced Visual Basic 6: Power Techniques for Everyday Programs
'   Author: Matthew Curland
'   Published by: Addison-Wesley, July 2000
'   ISBN: 0-201-70712-8
'   http://www.PowerVB.com
'
' You are entitled to license free distribution of any application
'   that uses this file if you own a copy of the book, or if you
'   have obtained the file from a source approved by the author. You
'   may redistribute this file only with express written permission
'   of the author.
'
' This file depends on:
'   References:
'     VBoostTypes6.olb (VBoost Object Types (6.0))
'     VBoost6.Dll (VBoost Object Implementation (6.0)) (optional)
'   Files:
'     VBoost.Bas
'   Minimal VBoost conditionals:
'     VBOOST_INTERNAL = 1 : VBOOST_CUSTOM = 1 : VBOOST_AggregateUnknown = 1
'   Conditional Compilation Values:
'     None
'
' This file is discussed in Chapter 8.
'***************************************************************
Option Explicit

#If False Then
'Sample usage of ObjectSafety
'Place this code in a UserControl to enable IObjectSafety.
'You can also use this lightweight interface implementation
'with normal classes that need to be consumed by the Windows
'Scripting Host. m_ObjSafe.CurrentSafety contains the current
'safety setting.
Private m_ObjSafe As ObjectSafety
Private m_Hook As UnknownHook
Private Sub UserControl_Initialize()
Dim AggData(0) As AggregateData
Dim IIDs(0) As IID
    InitObjectSafety m_ObjSafe, AggData(0), IIDs(0), 0, _
      Me, _
      INTERFACESAFE_FOR_UNTRUSTED_CALLER Or _
      INTERFACESAFE_FOR_UNTRUSTED_DATA
    VBoost.AggregateUnknown Me, AggData, IIDs, m_Hook
End Sub
'End of sample code
#End If

Private Const strIID_IObjectSafety As String = "{CB5BDC81-93C1-11cf-8F20-00805F2CD064}"

Private Type IObjectSafetyVTable
    VTable(4) As Long
End Type

Private m_VTable As IObjectSafetyVTable
Private m_pVTable As Long

Private IID_IObjectSafety As VBGUID

Public Enum SafetyOptions
    INTERFACESAFE_FOR_UNTRUSTED_CALLER = 1
    INTERFACESAFE_FOR_UNTRUSTED_DATA = 2
    INTERFACESAFE_USES_DISPEX = 4
    INTERFACE_USES_SECURITY_MANAGER = 8
End Enum

Public Type ObjectSafety
    pVTable As Long
    CurrentSafety As SafetyOptions
    SupportedSafety As SafetyOptions
    pUnkOuter As Long
End Type
Public Sub InitObjectSafety(ObjSafe As ObjectSafety, AggData As AggregateData, IID As IID, ByVal IIDNumber As Long, ByVal punkControllingIUnknown As IUnknown, ByVal Supported As SafetyOptions)
    If m_pVTable = 0 Then
        'VBoost may not be initialized in a UserControl
        'at design time.
        If VBoost Is Nothing Then InitVBoost
        IID_IObjectSafety = IIDFromString(strIID_IObjectSafety)
        With m_VTable
            .VTable(0) = FuncAddr(AddressOf QueryInterface)
            .VTable(1) = FuncAddr(AddressOf AddRefRelease)
            .VTable(2) = .VTable(1)
            .VTable(3) = FuncAddr(AddressOf GetInterfaceSafetyOptions)
            .VTable(4) = FuncAddr(AddressOf SetInterfaceSafetyOptions)
            m_pVTable = VarPtr(.VTable(0))
        End With
    End If
    
    'Create the lightweight object
    With ObjSafe
        .pVTable = m_pVTable
        .CurrentSafety = 0
        .SupportedSafety = Supported
        'ObjPtr without the AddRef/Release
        VBoost.Assign .pUnkOuter, punkControllingIUnknown
        IID = IID_IObjectSafety
    End With
    'Populate the AggregateData structure
    With AggData
        VBoost.Assign .pObject, VarPtr(ObjSafe)
        .FirstIID = IIDNumber
        .Flags = adUseIIDs Or adFullyResolved
        IID = IID_IObjectSafety
    End With
End Sub

Private Function QueryInterface(ByVal This As Long, riid As VBGUID, pvObj As Long) As Long
    'This structure is used as an aggregate with both the
    'adUseIIDs and adFullyResolved flags set, which means
    'that it will never actually receive a QueryInterface
    'call.
    Debug.Assert False
    pvObj = 0
    QueryInterface = E_NOINTERFACE
End Function
Private Function AddRefRelease(ByVal This As Long) As Long
    'No need to AddRef or Release. This is used inside a
    'blind delegator, which holds the necessary reference
    'on the controlling IUnknown, and the memory is owned
    'by the controlling IUnknown.
End Function

Private Function GetInterfaceSafetyOptions(This As ObjectSafety, riid As VBGUID, pdwSupportedOptions As SafetyOptions, pdwEnabledOptions As SafetyOptions) As Long
    With This
        If CheckInterface(.pUnkOuter, riid) Then
            'Set the options
            pdwSupportedOptions = .SupportedSafety
            pdwEnabledOptions = .CurrentSafety
        Else
            'Failure case
            GetInterfaceSafetyOptions = E_NOINTERFACE
            pdwSupportedOptions = 0
            pdwEnabledOptions = 0
        End If
    End With
End Function
Private Function SetInterfaceSafetyOptions(This As ObjectSafety, riid As VBGUID, ByVal dwOptionSetMask As SafetyOptions, ByVal dwEnabledOptions As SafetyOptions) As Long
    With This
        If CheckInterface(.pUnkOuter, riid) Then
            If dwOptionSetMask And Not .SupportedSafety Then
                SetInterfaceSafetyOptions = E_FAIL
            Else
                'Toggle only the specified safety bits
                .CurrentSafety = (.CurrentSafety And Not dwEnabledOptions) Or dwOptionSetMask
            End If
        Else
            SetInterfaceSafetyOptions = E_NOINTERFACE
        End If
    End With
End Function
'Helper function to verify if an interface is supported
Private Function CheckInterface(ByVal pWeakUnk As Long, riid As VBGUID) As Boolean
Dim pUnk As IUnknownUnrestricted
Dim pvObj As Long
    If pWeakUnk = 0 Then Exit Function
    With VBoost
        .Assign pUnk, pWeakUnk
        'Test for the interface
        If 0 = pUnk.QueryInterface(riid, pvObj) Then
            'Clear the reference
            .Assign pUnk, pvObj
            pUnk.Release
            CheckInterface = True
        End If
        .AssignZero pUnk
    End With
End Function
Private Function FuncAddr(ByVal pfn As Long) As Long
    FuncAddr = pfn
End Function

